home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Best of Shareware
/
Best of PC Windows Shareware 1.0 - Wayzata Technology (7111) (1993).iso
/
mac
/
ZIPPED
/
DOS
/
PROGRAMG
/
FORTHCMP.ZIP
/
HANOI.4TH
< prev
next >
Wrap
Text File
|
1992-03-30
|
4KB
|
131 lines
\ Towers of Hanoi, by Peter Midnight
\ from FORTH DIMENSIONS, Vol II, No. 2, page 32 )
\ NOTICE: THIS SAMPLE PROGRAM IS FOR IBM-PC'S OR COMPATIBLES ONLY!
256 MSDOS
2 0 IN/OUT
CODE GOTOXY
AL DH MOV BL DL MOV BH BH XOR 2 # AH MOV 16 INT RET END-CODE
0 0 IN/OUT
CODE CLEARSCREEN
3 # AX MOV 16 INT RET END-CODE
0 0 IN/OUT
: ABORT 0 0 BDOS ; ( NEVER RETURNS )
2 0 IN/OUT
CODE CCHARS ( character+color count -- )
AX CX MOV BL AL MOV BH BL MOV BH BH XOR 9 # AH MOV 16 INT RET
END-CODE
12 CONSTANT NMAX
VARIABLE N ( formerly a constant )
VARIABLE DELAY-TIME
0 CONSTANT FALSE
219 4 256 * + CONSTANT COLOR ( ring )
219 12 256 * + CONSTANT BRIGHT ( bright ring )
186 2 256 * + CONSTANT STAKE ( vertical bar )
176 1 256 * + CONSTANT STAND ( flat base )
DSEG CREATE RING NMAX 2+ ALLOT
: 4DUP 3 PICK 3 PICK 3 PICK 3 PICK ;
1 0 IN/OUT
: DELAY ( centiseconds delay )
0 DO 1000 0 DO LOOP LOOP ;
0 0 IN/OUT
: SLOWER DELAY-TIME @ 0 DO LOOP ;
1 1 IN/OUT
: POS ( location pos -> coordinate )
N @ 2* 1+ * N @ + ;
: DISPLAY ( size pos line color --- )
2 PICK 4 PICK - 2 PICK GOTOXY
OVER 3 < OVER BL <> OR
IF -ROT 2DROP SWAP 2* 1+ CCHARS ELSE
DUP 4 PICK CCHARS
2 PICK 2 PICK GOTOXY STAKE 1 CCHARS
-ROT SWAP 1+ SWAP GOTOXY SWAP CCHARS THEN ;
2 1 IN/OUT
: PRESENCE ( tower ring presence -> boolean )
RING + C@ = ;
: LINE ( tower line -> display-line-of-top )
4 SWAP N @ 0
DO DUP I PRESENCE 0= IF SWAP 1+ SWAP THEN LOOP
DROP ;
: RAISE ( size tower --- )
DUP POS SWAP LINE 2 SWAP
DO 2DUP I BL DISPLAY 2DUP I 1- BRIGHT DISPLAY SLOWER -1 +LOOP
2DROP ;
: LOWER ( size tower --- )
DUP POS SWAP LINE DUP >R 1+ 2
DO 2DUP I 1- BL DISPLAY 2DUP I BRIGHT DISPLAY SLOWER LOOP
R> COLOR DISPLAY ;
: MOVELEFT ( size source.tower destiny.tower --- )
POS SWAP POS 1-
DO DUP I 1+ 1 BL DISPLAY DUP I 1 BRIGHT DISPLAY SLOWER -1 +LOOP
DROP ;
: MOVERIGHT ( size source.tower destiny.tower --- )
POS 1+ SWAP POS 1+
DO DUP I 1- 1 BL DISPLAY DUP I 1 BRIGHT DISPLAY SLOWER LOOP
DROP ;
: TRAVERSE ( size source.tower destiny.tower --- )
2DUP > IF MOVELEFT ELSE MOVERIGHT THEN ;
: MOVE ( size source.tower destiny.tower --- )
?TERMINAL IF 0 N @ 4 + GOTOXY ABORT THEN
-ROT 2DUP RAISE
>R 2DUP R> ROT TRAVERSE
2DUP RING + 1- C! SWAP LOWER ;
: MULTIMOV ( size source destiny spare --- )
3 PICK 1 = IF DROP MOVE ELSE
>R >R SWAP 1- SWAP R> R> 4DUP SWAP MULTIMOV
4DUP DROP ROT 1+ -ROT MOVE
-ROT SWAP MULTIMOV THEN ;
: MAKETOWER ( tower --- ) POS 4 N @ + 3
DO DUP I GOTOXY STAKE 1 CCHARS LOOP
DROP ;
: MAKEBASE ( no arguments ) 0 N @ 4 + GOTOXY
STAND N @ 6 * 3 + CCHARS ;
: MAKERING ( tower size --- )
2DUP RING + 1- C! SWAP LOWER ;
: SETUP ( no arguments )
CLEARSCREEN N @ 1+ 0 DO 1 RING I + C! LOOP
3 0 DO I MAKETOWER LOOP
MAKEBASE
1 N @ DO 0 I MAKERING -1 +LOOP ;
: TOWERS ( quantity --- )
1 MAX NMAX MIN N !
SETUP N @ 2 0 1
BEGIN
OVER POS N @ 4 + GOTOXY N @ 0
DO 7 EMIT 20 DELAY LOOP
ROT 4DUP MULTIMOV
FALSE
UNTIL ;
: MAIN CR ." DELAY TIME? " #IN 1 MAX DELAY-TIME !
CR ." HOW MANY RINGS? " #IN TOWERS ;
INCLUDE FORTHLIB
END